Documentation: This takes simulations from the cooperative corruption simulations and plots them.
Simulations depend on CoopCor function in ABM.rmd file
I. PROTOTYPICAL SCENARIOS
simulation_files <- list.files("data/sims/sim_plots/")
scenarios <- list()
for(i in seq_along(simulation_files)){
scenarios[[i]] <- read_csv(paste0("data/sims/sim_plots/",simulation_files[i]))
}
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_double(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_double(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_integer(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_double(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_double(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_integer(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_double(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_integer(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
## Parsed with column specification:
## cols(
## P1_roll = col_integer(),
## P2_roll = col_integer(),
## P1_cheat = col_integer(),
## P2_cheat = col_integer(),
## check = col_integer(),
## cheated = col_integer(),
## payoff = col_integer(),
## th_payoff = col_integer(),
## ingame = col_integer(),
## n_game = col_integer()
## )
names(scenarios) <- str_remove(simulation_files, ".csv")
scenario_summaries <- list()
for(i in (seq_along(scenarios))){
scenario_summaries[[i]] <- assign(paste(names(scenarios)[i], "summary", sep = "_"), scenarios[[i]]) %>%
group_by(n_game) %>%
mutate(turnID = row_number()) %>%
ungroup()
names(scenario_summaries)[i] <- names(scenarios)[i]
}
scenario_full <- plyr::ldply(scenario_summaries, data.frame) %>%
mutate(is_heuristic = ifelse(.id == "TheoreticalLeader" | .id == "BiasedLeader",1,0))
scenario_comparison <- scenario_full %>%
group_by(turnID,.id) %>%
summarise(is_heuristic = mean(cumprod(is_heuristic)),
mean_pay = mean(payoff),
std = sd(payoff),
N = n(),
se = std/sqrt(N),
lowbeta = mean(qbeta(0.025, payoff + .5, N - payoff + .5)),
highbeta = mean(qbeta(0.975, payoff + .5, N - payoff + .5))) %>%
ungroup() %>%
group_by(.id) %>%
mutate(cum_pay = cumsum(mean_pay))
#We summarise the full dataset
game_summaries <- scenario_full %>% group_by(.id,n_game) %>%
summarise(total_pay = sum(payoff),
ingame_dummy = min(cumprod(ingame)),
is_heuristic = min(cumprod(is_heuristic))) %>%
mutate(actual_pay = ifelse(ingame_dummy == 0, 0, total_pay))
###### Raincloud Plot
#with all scenarios
game_summaries %>%
ungroup() %>%
mutate(.id = fct_reorder(.id, desc(actual_pay))) %>%
ggplot(aes(x = .id, y = actual_pay, fill = .id)) +
geom_flat_violin(position = position_nudge(x = .2, y = 0)) +
geom_point(aes(color = .id),position = position_jitter(width = .15), size = .2) +
geom_boxplot(width = .1, alpha = 0.5, outlier.shape = NA, show.legend = FALSE) +
scale_fill_manual(values = ggsci::pal_aaas()(9)) +
scale_color_manual(values = ggsci::pal_aaas()(9)) +
labs(title = "Payouts Raincloud Plot", x = "Scenarios", y = "Actual Payouts") +
coord_flip() +
theme_minimal(base_size = 24) +
guides(fill = FALSE, color = FALSE)
#ggsave("figures/RaincloudPlot_actual_payouts_ALL.png", device = "png", width = 15, height = 10)
#without smart leaders
game_summaries %>%
ungroup() %>%
filter(is_heuristic == 0) %>%
mutate(.id = fct_reorder(.id, desc(actual_pay))) %>%
ggplot(aes(x = .id, y = actual_pay, fill = .id)) +
geom_flat_violin(position = position_nudge(x = .2, y = 0)) +
geom_point(aes(color = .id),position = position_jitter(width = .15), size = .2) +
geom_boxplot(width = .1, alpha = 0.5, outlier.shape = NA, show.legend = FALSE) +
scale_fill_manual(values = ggsci::pal_aaas()(9)) +
scale_color_manual(values = ggsci::pal_aaas()(9)) +
labs(title = "Payouts Raincloud Plot", x = "Scenarios", y = "Actual Payouts") +
coord_flip() +
theme_minimal(base_size = 24) +
guides(fill = FALSE, color = FALSE)
#ggsave("figures/RaincloudPlot_actual_payouts_no_heuristics.png", device = "png", width = 15, height = 10)
####### Simple bar plot
#with all scenarios
game_summaries %>%
group_by(.id) %>%
summarise(mean_actual_pay = mean(actual_pay),
N = n(),
std = sd(actual_pay),
se = std/sqrt(N)) %>%
mutate(.id = fct_reorder(.id, desc(mean_actual_pay))) %>%
ggplot(aes(x = .id, y = mean_actual_pay, fill = .id)) +
geom_bar(stat = "identity") +
geom_errorbar(aes(ymin = mean_actual_pay - se, ymax = mean_actual_pay + se), width = 0.3) +
scale_fill_manual(values = ggsci::pal_aaas()(9)) +
theme(axis.text = element_text(angle = 45, hjust = 1)) +
labs(title = "Mean Actual Payouts by Scenario (N = 1000)", fill = "Scenario", x = "Scenarios", y = "Mean Actual Payout" )
#ggsave("figures/mean_actual_payouts.png", device = "png", width = 15, height = 7.5)
#witohut smart leaders
game_summaries %>%
filter(is_heuristic == 0) %>%
group_by(.id) %>%
summarise(mean_actual_pay = mean(actual_pay),
N = n(),
std = sd(actual_pay),
se = std/sqrt(N)) %>%
mutate(.id = fct_reorder(.id, desc(mean_actual_pay))) %>%
ggplot(aes(x = .id, y = mean_actual_pay, fill = .id)) +
geom_bar(stat = "identity") +
geom_errorbar(aes(ymin = mean_actual_pay - se, ymax = mean_actual_pay + se), width = 0.3) +
scale_fill_manual(values = ggsci::pal_aaas()(9)) +
theme(axis.text = element_text(angle = 45, hjust = 1)) +
labs(title = "Mean Actual Payouts by Scenario (N = 1000)", fill = "Scenario", x = "Scenarios", y = "Mean Actual Payout" )
#ggsave("figures/mean_actual_payouts_no_heuristics.png", device = "png", width = 15, height = 7.5)
II. SMART AND ETHICAL LEADERS
sim_comb_sum <- read.csv("data/sims/leader_heuristic/sim_comb_sum.csv")
sim_comb <- read.csv("data/sims/leader_heuristic/sim_comb.csv")
About money?
#The mean cumulative pay:
#The total money a team makes, averaged over number of games
#mean cumulative pay by round number
sim_comb_sum %>%
ggplot(aes(x = turnID, y = mean_cum_actual_pay, color = bias)) +
geom_line(aes(group = bias)) +
scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
facet_wrap(~heuristic)
What is the state of the games at last round?
rounds=100
#Creating a dataframe with data only from last round
sim_comb_max <- sim_comb_sum %>%
filter(turnID == rounds)
sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_actual_pay, fill = heuristic)) +
geom_bar(stat = "identity", position = "dodge")
## At last round
## What we have when the game ends
#gains for each cheating bias and heuristic, averaged over the 250 games
sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_pay, color = heuristic)) +
geom_point() + geom_smooth(method = 'lm')
#actual gains (accounting for failed games) for each cheating bias and heuristic, averaged over the 250 games
sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_actual_pay, color = heuristic)) +
geom_point() + geom_smooth()
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
#total lost games on 250 runs by bias and heuristics
sim_comb_max %>% ggplot(aes(x = bias, y = sum_lost_game, color = heuristic)) +
geom_point() + geom_smooth()
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
Everything about the dynamics between checks and cheats: We have 2*2 possibilities -A check matched by a cheat: good job! -A check without a cheat: you’re being too suspicious, you wasted the company’s money -No check but cheat: you failed at your job -No check no cheat: we don’t care so much
#overall checking
sim_comb_sum %>%
ggplot(aes(x = bias, y = sum_checks, color = heuristic)) +
geom_point() +
geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'
#failed checks
sim_comb_sum %>%
ggplot(aes(x = bias, y = sum_unchecked_cheat, color = heuristic)) +
geom_point() +
geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'
#successeful checks
sim_comb_sum %>%
ggplot(aes(x = bias, y = sum_checked_cheat, color = heuristic)) +
geom_point() +
geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'
#unnecessary checks
sim_comb_sum %>%
ggplot(aes(x = bias, y = sum_useless_check, color = heuristic)) +
geom_point() +
geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'
###The evolution of checks across runs by bias
#failed checks
sim_comb_sum %>%
ggplot(aes(x = turnID, y = sum_unchecked_cheat, color = bias)) +
geom_line(aes(group = bias)) +
scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
facet_wrap(~heuristic)
#succesfull checks
sim_comb_sum %>%
ggplot(aes(x = turnID, y = sum_checked_cheat, color = bias)) +
geom_line(aes(group = bias)) +
scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
facet_wrap(~heuristic)
#unnecessary checks
sim_comb_sum %>%
ggplot(aes(x = turnID, y = sum_useless_check, color = bias)) +
geom_line(aes(group = bias)) +
scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
facet_wrap(~heuristic)
It seems that:
On the cumulative payoff -With a forgiving leader, any amount of cheating brings better results -With a grudgy leader, any amount of cheating brings worst results
When taking into account the failed games (payoff drops to 0 because of GREED and BAD LUCK) On the actual cumulative pay off -Never cheating still brings the best result -Having a grudgy leader leads to a drastic decrease of gains the more cheating happens -Having a forgiving leader leads to slight decrease of gains when cheating increases